home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / print.c < prev    next >
C/C++ Source or Header  |  1992-10-21  |  13KB  |  550 lines
  1. #include <errno.h>
  2. #include <ctype.h>
  3. #include <varargs.h>
  4. #include <sys/ioctl.h>
  5.  
  6. #include "scheme.h"
  7.  
  8. extern int errno;
  9.  
  10. int Saved_Errno;
  11.  
  12. static Object V_Print_Depth, V_Print_Length;
  13.  
  14. Init_Print () {
  15.     Define_Variable (&V_Print_Depth, "print-depth",
  16.     Make_Fixnum (DEF_PRINT_DEPTH));
  17.     Define_Variable (&V_Print_Length, "print-length",
  18.     Make_Fixnum (DEF_PRINT_LEN));
  19. }
  20.  
  21. Print_Length () {
  22.     Object pl;
  23.  
  24.     pl = Var_Get (V_Print_Length);
  25.     return TYPE(pl) == T_Fixnum ? FIXNUM(pl) : DEF_PRINT_LEN;
  26. }
  27.  
  28. Print_Depth () {
  29.     Object pd;
  30.  
  31.     pd = Var_Get (V_Print_Depth);
  32.     return TYPE(pd) == T_Fixnum ? FIXNUM(pd) : DEF_PRINT_DEPTH;
  33. }
  34.  
  35. Print_Char (port, c) Object port; register c; {
  36.     char buf[1];
  37.  
  38.     if (PORT(port)->flags & P_STRING) {
  39.     buf[0] = c;
  40.     Print_String (port, buf, 1);
  41.     } else {
  42.     if (putc (c, PORT(port)->file) == EOF)  {
  43.         Saved_Errno = errno;   /* errno valid here? */
  44.         Primitive_Error ("write error on ~s: ~E", port);
  45.     }
  46.     }
  47. }
  48.  
  49. Print_String (port, buf, len) Object port; register char *buf; register len; {
  50.     register n;
  51.     register struct S_Port *p;
  52.     Object new;
  53.     GC_Node;
  54.  
  55.     p = PORT(port);
  56.     n = STRING(p->name)->size - p->ptr;
  57.     if (n < len) {
  58.     GC_Link (port);
  59.     n = len - n;
  60.     if (n < STRING_GROW_SIZE)
  61.         n = STRING_GROW_SIZE;
  62.     new = Make_String ((char *)0, STRING(p->name)->size + n);
  63.     p = PORT(port);
  64.     GC_Unlink;
  65.     bcopy (STRING(p->name)->data, STRING(new)->data, p->ptr);
  66.     p->name = new;
  67.     }
  68.     bcopy (buf, STRING(p->name)->data + p->ptr, len);
  69.     p->ptr += len;
  70. }
  71.  
  72. #ifndef VPRINTF
  73. vfprintf (f, fmt, ap) register FILE *f; register char *fmt; va_list ap; {
  74.     _doprnt (fmt, ap, f);
  75. }
  76.  
  77. vsprintf (s, fmt, ap) register char *s, *fmt; va_list ap; {
  78.     FILE x;
  79.     x._flag = _IOWRT|_IOSTRG;
  80.     x._ptr = s;
  81.     x._cnt = 1024;
  82.     _doprnt (fmt, ap, &x);
  83.     putc ('\0', &x);
  84. }
  85. #endif
  86.  
  87. /*VARARGS0*/
  88. Printf (va_alist) va_dcl {
  89.     va_list args;
  90.     Object port;
  91.     char *fmt;
  92.     char buf[1024];
  93.  
  94.     va_start (args);
  95.     port = va_arg (args, Object);
  96.     fmt = va_arg (args, char *);
  97.     if (PORT(port)->flags & P_STRING) {
  98.     vsprintf (buf, fmt, args);
  99.     Print_String (port, buf, strlen (buf));
  100.     } else {
  101.     vfprintf (PORT(port)->file, fmt, args);
  102.     if (ferror (PORT(port)->file)) {
  103.         Saved_Errno = errno;   /* errno valid here? */
  104.         Primitive_Error ("write error on ~s: ~E", port);
  105.     }
  106.     }
  107.     va_end (args);
  108. }
  109.  
  110. Object General_Print (argc, argv, raw) Object *argv; {
  111.     General_Print_Object (argv[0], argc == 2 ? argv[1] : Curr_Output_Port, raw);
  112.     return Void;
  113. }
  114.  
  115. Object P_Write (argc, argv) Object *argv; {
  116.     return General_Print (argc, argv, 0);
  117. }
  118.  
  119. Object P_Display (argc, argv) Object *argv; {
  120.     return General_Print (argc, argv, 1);
  121. }
  122.  
  123. Object P_Write_Char (argc, argv) Object *argv; {
  124.     Check_Type (argv[0], T_Character);
  125.     return General_Print (argc, argv, 1);
  126. }
  127.  
  128. /*VARARGS1*/
  129. Object P_Newline (argc, argv) Object *argv; {
  130.     General_Print_Object (Newline, argc == 1 ? argv[0] : Curr_Output_Port, 1);
  131.     return Void;
  132. }
  133.  
  134. Object P_Print (argc, argv) Object *argv; {
  135.     Object port;
  136.     GC_Node;
  137.  
  138.     port = argc == 2 ? argv[1] : Curr_Output_Port;
  139.     GC_Link (port);
  140.     General_Print_Object (argv[0], port, 0);
  141.     Print_Char (port, '\n');
  142.     Flush_Output (port);
  143.     GC_Unlink;
  144.     return Void;
  145. }
  146.  
  147. Object P_Clear_Output_Port (argc, argv) Object *argv; {
  148.     Discard_Output (argc == 1 ? argv[0] : Curr_Output_Port);
  149.     return Void;
  150. }
  151.  
  152. Discard_Output (port) Object port; {
  153.     register FILE *f;
  154.  
  155.     Check_Output_Port (port);
  156.     if (PORT(port)->flags & P_STRING)
  157.     return;
  158.     f = PORT(port)->file;
  159.     f->_cnt = 0;
  160.     f->_ptr = f->_base;
  161. #ifdef TIOCFLUSH
  162.     (void)ioctl (fileno (f), TIOCFLUSH, (char *)0);
  163. #endif
  164. }
  165.  
  166. Object P_Flush_Output_Port (argc, argv) Object *argv; {
  167.     Flush_Output (argc == 1 ? argv[0] : Curr_Output_Port);
  168.     return Void;
  169. }
  170.  
  171. Flush_Output (port) Object port; {
  172.     Check_Output_Port (port);
  173.     if (PORT(port)->flags & P_STRING)
  174.     return;
  175.     if (fflush (PORT(port)->file) == EOF) {
  176.     Saved_Errno = errno;   /* errno valid here? */
  177.     Primitive_Error ("write error on ~s: ~E", port);
  178.     }
  179. }
  180.  
  181. Object P_Get_Output_String (port) Object port; {
  182.     register struct S_Port *p;
  183.     Object str;
  184.     GC_Node;
  185.  
  186.     Check_Output_Port (port);
  187.     GC_Link (port);
  188.     str = Make_String ((char *)0, PORT(port)->ptr);
  189.     p = PORT(port);
  190.     bcopy (STRING(p->name)->data, STRING(str)->data, p->ptr);
  191.     p->ptr = 0;
  192.     GC_Unlink;
  193.     return str;
  194. }
  195.     
  196. Check_Output_Port (port) Object port; {
  197.     Check_Type (port, T_Port);
  198.     if (!(PORT(port)->flags & P_OPEN))
  199.     Primitive_Error ("port has been closed: ~s", port);
  200.     if (!IS_OUTPUT(port))
  201.     Primitive_Error ("not an output port: ~s", port);
  202. }
  203.  
  204. General_Print_Object (x, port, raw) Object x, port; {
  205.     Check_Output_Port (port);
  206.     Print_Object (x, port, raw, Print_Depth (), Print_Length ());
  207. }
  208.  
  209. Print_Object (x, port, raw, depth, length) Object x, port;
  210.     register raw, depth, length; {
  211.     register t;
  212.     GC_Node2;
  213.  
  214.     GC_Link2 (port, x);
  215.     t = TYPE(x);
  216.     switch (t) {
  217.     case T_Null:
  218.     Printf (port, "()");
  219.     break;
  220.     case T_Fixnum:
  221.     Printf (port, "%d", FIXNUM(x));
  222.     break;
  223.     case T_Bignum:
  224.     Print_Bignum (port, x);
  225.     break;
  226.     case T_Flonum:
  227.     Printf (port, FLONUM_FORMAT, FLONUM(x)->val);
  228.     break;
  229.     case T_Boolean:
  230.     Printf (port, "#%c", FIXNUM(x) ? 't' : 'f');
  231.     break;
  232.     case T_Void:
  233.     break;
  234.     case T_Unbound:
  235.     Printf (port, "#[unbound]");
  236.     break;
  237.     case T_Special:
  238.     Printf (port, "#[special]");
  239.     break;
  240.     case T_Character: {
  241.     int c = CHAR(x);
  242.     if (raw)
  243.         Print_Char (port, c);
  244.     else
  245.         Pr_Char (port, c);
  246.     break;
  247.     }
  248.     case T_Symbol:
  249.     Pr_String (port, SYMBOL(x)->name, 1);
  250.     break;
  251.     case T_Pair:
  252.     Pr_List (port, x, raw, depth, length);
  253.     break;
  254.     case T_Environment:
  255.     Printf (port, "#[environment %u]", POINTER(x));
  256.     break;
  257.     case T_String:
  258.     Pr_String (port, x, raw);
  259.     break;
  260.     case T_Vector:
  261.     Pr_Vector (port, x, raw, depth, length);
  262.     break;
  263.     case T_Primitive:
  264.     Printf (port, "#[primitive %s]", PRIM(x)->name);
  265.     break;
  266.     case T_Compound:
  267.     if (Nullp (COMPOUND(x)->name)) {
  268.         Printf (port, "#[compound %u]", POINTER(x));
  269.     } else {
  270.         Printf (port, "#[compound ");
  271.         Print_Object (COMPOUND(x)->name, port, raw, depth, length);
  272.         Print_Char (port, ']');
  273.     }
  274.     break;
  275.     case T_Control_Point:
  276.     Printf (port, "#[control-point %u]", POINTER(x));
  277.     break;
  278.     case T_Promise:
  279.     Printf (port, "#[promise %u]", POINTER(x));
  280.     break;
  281.     case T_Port: {
  282.     int str = PORT(x)->flags & P_STRING;
  283.     char *p;
  284.     switch (PORT(x)->flags & (P_INPUT|P_BIDIR)) {
  285.     case 0:       p = "output";       break;
  286.     case P_INPUT: p = "input";        break;
  287.     default:      p = "input-output"; break;
  288.     }
  289.     Printf (port, "#[%s-%s-port ", str ? "string" : "file", p);
  290.     if (str)
  291.         Printf (port, "%u", POINTER(x));
  292.     else
  293.         Pr_String (port, PORT(x)->name, 0);
  294.     Print_Char (port, ']');
  295.     break;
  296.     }
  297.     case T_End_Of_File:
  298.     Printf (port, "#[end-of-file]");
  299.     break;
  300.     case T_Autoload:
  301.     Printf (port, "#[autoload ");
  302.     Print_Object (AUTOLOAD(x)->files, port, raw, depth, length);
  303.     Print_Char (port, ']');
  304.     break;
  305.     case T_Macro:
  306.     if (Nullp (MACRO(x)->name)) {
  307.         Printf (port, "#[macro %u]", POINTER(x));
  308.     } else {
  309.         Printf (port, "#[macro ");
  310.         Print_Object (MACRO(x)->name, port, raw, depth, length);
  311.         Print_Char (port, ']');
  312.     }
  313.     break;
  314.     case T_Broken_Heart:
  315.     Printf (port, "!!broken-heart!!");
  316.     break;
  317.     default:
  318.     if (t < 0 || t >= MAX_TYPE || !Types[t].name)
  319.         Panic ("bad type in print");
  320.     (*Types[t].print)(x, port, raw, depth, length);
  321.     }
  322.     GC_Unlink;
  323. }
  324.  
  325. Pr_Char (port, c) Object port; register c; {
  326.     register char *p = 0;
  327.  
  328.     switch (c) {
  329.     case ' ':
  330.     p = "#\\space";
  331.     break;
  332.     case '\t':
  333.     p = "#\\tab";
  334.     break;
  335.     case '\n':
  336.     p = "#\\newline";
  337.     break;
  338.     case '\r':
  339.     p = "#\\return";
  340.     break;
  341.     case '\f':
  342.     p = "#\\formfeed";
  343.     break;
  344.     case '\b':
  345.     p = "#\\backspace";
  346.     break;
  347.     default:
  348.     if (c > ' ' && c < '\177')
  349.         Printf (port, "#\\%c", c);
  350.     else
  351.         Printf (port, "#\\%03o", (unsigned char)c);
  352.     }
  353.     if (p) Printf (port, p);
  354. }
  355.  
  356. Pr_List (port, list, raw, depth, length) Object port, list;
  357.     register raw, depth, length; {
  358.     Object tail;
  359.     register len;
  360.     register char *s = 0;
  361.     GC_Node2;
  362.  
  363.     if (depth == 0) {
  364.     Printf (port, "&");
  365.     return;
  366.     }
  367.     GC_Link2 (port, list);
  368.     if (!Nullp (list) && ((tail = Cdr (list)), TYPE(tail) == T_Pair)
  369.               && ((tail = Cdr (tail)), Nullp (tail))) {
  370.     tail = Car (list);
  371.     if (EQ(tail, Sym_Quote))
  372.         s = "'";
  373.     else if (EQ(tail, Sym_Quasiquote))
  374.         s = "`";
  375.     else if (EQ(tail, Sym_Unquote))
  376.         s = ",";
  377.     else if (EQ(tail, Sym_Unquote_Splicing))
  378.         s = ",@";
  379.     if (s) {
  380.         Printf (port, s);
  381.         Print_Object (Car (Cdr (list)), port, raw,
  382.         depth < 0 ? depth : depth-1, length);
  383.         GC_Unlink;
  384.         return;
  385.     }
  386.     }
  387.     Print_Char (port, '(');
  388.     for (len = 0; !Nullp (list); len++, list = tail) {
  389.     if (length >= 0 && len >= length) {
  390.         Printf (port, "...");
  391.         break;
  392.     }
  393.     Print_Object (Car (list), port, raw, depth < 0 ? depth : depth-1,
  394.          length);
  395.     tail = Cdr (list);
  396.     if (!Nullp (tail)) {
  397.         if (TYPE(tail) == T_Pair)
  398.         Print_Char (port, ' ');
  399.         else {
  400.         Printf (port, " . ");
  401.         Print_Object (tail, port, raw, depth < 0 ? depth : depth-1,
  402.              length);
  403.         break;
  404.         }
  405.     }
  406.     }
  407.     Print_Char (port, ')');
  408.     GC_Unlink;
  409. }
  410.  
  411. Pr_Vector (port, vec, raw, depth, length) Object port, vec;
  412.     register raw, depth, length; {
  413.     register i, j;
  414.     GC_Node2;
  415.  
  416.     if (depth == 0) {
  417.     Printf (port, "&");
  418.     return;
  419.     }
  420.     GC_Link2 (port, vec);
  421.     Printf (port, "#(");
  422.     for (i = 0, j = VECTOR(vec)->size; i < j; i++) {
  423.     if (i) Print_Char (port, ' ');
  424.     if (length >= 0 && i >= length) {
  425.         Printf (port, "...");
  426.         break;
  427.     }
  428.     Print_Object (VECTOR(vec)->data[i], port, raw,
  429.          depth < 0 ? depth : depth-1, length);
  430.     }
  431.     Print_Char (port, ')');
  432.     GC_Unlink;
  433. }
  434.  
  435. Pr_String (port, str, raw) Object port, str; {
  436.     register char *p = STRING(str)->data;
  437.     register c, i, len = STRING(str)->size;
  438.     GC_Node2;
  439.  
  440.     if (raw) {
  441.     if (PORT(port)->flags & P_STRING) {
  442.         Print_String (port, p, len);
  443.     } else {
  444.         if (fwrite (p, 1, len, PORT(port)->file) < len) {
  445.         Saved_Errno = errno;   /* errno valid here? */
  446.         Primitive_Error ("write error on ~s: ~E", port);
  447.         }
  448.     }
  449.     return;
  450.     }
  451.     GC_Link2 (port, str);
  452.     Print_Char (port, '"');
  453.     for (i = 0; i < STRING(str)->size; i++) {
  454.     c = STRING(str)->data[i];
  455.     if (c == '\\' || c == '"')
  456.         Print_Char (port, '\\');
  457.     if (c < ' ' || c >= '\177')
  458.         Print_Special (port, c);
  459.     else
  460.     Print_Char (port, c);
  461.     }
  462.     Print_Char (port, '"');
  463.     GC_Unlink;
  464. }
  465.  
  466. Print_Special (port, c) Object port; register c; {
  467.     register char *fmt = "\\%c";
  468.  
  469.     switch (c) {
  470.     case '\b': c = 'b'; break;
  471.     case '\t': c = 't'; break;
  472.     case '\r': c = 'r'; break;
  473.     case '\n': c = 'n'; break;
  474.     default:
  475.     fmt = "\\%03o";
  476.     }
  477.     Printf (port, fmt, (unsigned char)c);
  478. }
  479.  
  480. Object P_Format (argc, argv) Object *argv; {
  481.     Object port, str;
  482.     register stringret = 0;
  483.     GC_Node;
  484.  
  485.     port = argv[0];
  486.     if (TYPE(port) == T_Boolean) {
  487.     if (Truep (port)) {
  488.         port = Curr_Output_Port;
  489.     } else {
  490.         stringret++;
  491.         port = P_Open_Output_String ();
  492.     }
  493.     } else if (TYPE(port) == T_Port) {
  494.     Check_Output_Port (port);
  495.     } else Wrong_Type_Combination (port, "port or #t or #f");
  496.     str = argv[1];
  497.     Check_Type (str, T_String);
  498.     GC_Link (port);
  499.     Format (port, STRING(str)->data, STRING(str)->size, argc-2, argv+2);
  500.     GC_Unlink;
  501.     return stringret ? P_Get_Output_String (port) : Void;
  502. }
  503.  
  504. Format (port, p, len, argc, argv) Object port; register char *p;
  505.     register len; Object *argv; {
  506.     register char *s, *ep;
  507.     register c;
  508.     char buf[256];
  509.     extern sys_nerr;
  510.     extern char *sys_errlist[];
  511.     GC_Node;
  512.  
  513.     GC_Link (port);
  514.     for (ep = p + len; p < ep; p++) {
  515.     if (*p == '~') {
  516.         if (++p == ep) break;
  517.         if ((c = *p) == '~') {
  518.         Print_Char (port, c);
  519.         } else if (c == '%') {
  520.         Print_Char (port, '\n');
  521.         } else if (c == 'e' || c == 'E') {
  522.         if (Saved_Errno > 0 && Saved_Errno < sys_nerr) {
  523.             s = sys_errlist[Saved_Errno];
  524.             sprintf (buf, "%c%s", isupper (*s) ? tolower (*s) :
  525.             *s, s+1);
  526.         } else {
  527.             sprintf (buf, "error %d", Saved_Errno);
  528.         }
  529.         Print_Object (Make_String (buf, strlen (buf)), port,
  530.             c == 'E', 0, 0);
  531.         } else {
  532.         if (--argc < 0)
  533.             Primitive_Error ("too few arguments");
  534.         if (c == 's' || c == 'a') {
  535.             Print_Object (*argv, port, c == 'a', Print_Depth (),
  536.             Print_Length ());
  537.             argv++;
  538.         } else if (c == 'c') {
  539.             Check_Type (*argv, T_Character);
  540.             Print_Char (port, CHAR(*argv));
  541.             argv++;
  542.         } else Print_Char (port, c);
  543.         }
  544.     } else {
  545.         Print_Char (port, *p);
  546.     }
  547.     }
  548.     GC_Unlink;
  549. }
  550.